;;########################################################################
;; dashobj2.lsp
;; Copyright (c) 1994-2002 by Forrest W. Young
;;
;; CURRENT-DATASHEET FUNCTIONS & METHODS
;; DEFPROTO and SLOT METHODS
;;
;;########################################################################


#|ORIGINAL____________________________________________

(defun setcds (datasheet)
  (when datasheet (set-current-datasheet datasheet))
  datasheet)

(defun set-current-datasheet (datasheet)
  (let* ((icon (send datasheet :dash-icon))
         (supr (send datasheet :supervisor)))
     (send icon :do-click)
     (when supr (set-current-data-supervisor supr))
     (when datasheet (send datasheet :set-symbols))
     datasheet))

_____________________________________________________|#


#|WORKING WITH COMMENTS______________________________

(defun setcds (&optional datasheet)
  (when datasheet
     (setf datasheet (send (send *workmap* :selected-icon-object) :object))
     ;(one-button-dialog (format nil "enter setcds for ~a" datasheet))
     (set-current-datasheet datasheet))
  datasheet)

(defun set-current-datasheet (datasheet)
;(print (list "set-current-datasheet" datasheet (if datasheet (send datasheet :object-id))))
  (unless (send (send datasheet :data-object) :iconify)
          (setf datasheet *current-datasheet*))
  (let* ((icon (send datasheet :dash-icon))
         (supr (send datasheet :supervisor)))
;(print (list "set-current-datasheet" (if datasheet (send datasheet :address) nil)
 ;            "icon" (if icon (send icon :title) nil)))
    (when icon (send icon :do-click))
    (when supr (set-current-data-supervisor supr))	
    (send datasheet :set-symbols))
  datasheet)
_____________________________________________________|#


#|WORKING WITHOUT COMMENTS___________________________

(defun setcds (&optional datasheet)
  (when datasheet
     (setf datasheet (send (send *workmap* :selected-icon-object) :object))
     (set-current-datasheet datasheet))
  datasheet)


(defun set-current-datasheet (datasheet)
  (unless (send (send datasheet :data-object) :iconify)
          (setf datasheet *current-datasheet*))
  (let* ((icon (send datasheet :dash-icon))
         (supr (send datasheet :supervisor)))
    (when icon (send icon :do-click))
    (when supr (set-current-data-supervisor supr))	
    (send datasheet :set-symbols))
  datasheet)

_____________________________________________________|#

(defun setcds (datasheet) (set-current-datasheet datasheet))

(defun set-current-datasheet (datasheet)
  (when (and datasheet
             (equal "dash" (send datasheet :statistical-object-type))
             (send (send datasheet :data-object) :iconify))
        (let* ((icon (send datasheet :dash-icon))
               (supr (send datasheet :supervisor)))
          (when icon (send icon :do-click))
          (when supr (set-current-data-supervisor supr))	
          (send datasheet :set-symbols)))
  datasheet)

(defun setcds-symbols (datasheet)
  (when datasheet (send datasheet :set-symbols))
  datasheet)


(defproto datasheet-proto '(data-object 
   data-matrix-strings variable-strings label-strings type-strings x+ y+ data-type editable edited nvar nobs nmat field-width field-height label-width corner-width hot-cell hot-cell-ready hot-cell-string menu-states new-data initial discarded number-of-columns number-of-decimals newvar newobs newmat showing top-window matrix-strings redraw-now help-menu-installed needs-revealing container size-loc shrink-wrap? editor dash-icon dash-popup-menu dob-parents dob-children name full-name extension elipsis-name proper-name supervisor statistical-object-type
known-as-name datasize-string datatype-string object-id elapsed-time statobj-start-time instance-info button-bar-showing? menu-bar-showing? dash-vartype-menu dash-menu-top-item) 
  nil graph-proto);graph-container

(defmeth datasheet-proto :isnew (&rest args)
;(format T ";DASHOBJ2: start DATASHEET-PROTO ISNEW~%")
  (unless (send self :statobj-start-time) 
            (send self :statobj-start-time (get-internal-real-time)))
  (apply #'call-next-method args)
  (when *vista-has-been-shown* (send self :set-symbols))
  )


(defmeth datasheet-proto :set-symbols ()
        (when *current-datasheet*
              (setf *previous-datasheet* *current-datasheet*))
        (setf *current-datasheet* self)
        (setf *datasheet* self)
        (setf current-datasheet self)
        (setf *cds* self)
        (setf cds self)
        (setf *co* self)
        (setf  co  self)
        (setf *current-object* self)
        (setf  current-object  self)
        (setf $$$ self)
        (setf @ self)
  self)


(defmeth datasheet-proto :nways-of-table (&optional (n nil set))
  (unless (send self :has-slot 'nways-of-table)
          (send self :add-slot 'nways-of-table))
  (if set (setf (slot-value 'nways-of-table) n))
  (slot-value 'nways-of-table)) 

(defmeth datasheet-proto :supervisor (&optional (objid nil set))
"Method args: (&optional time)
 Sets or retrieves object id of the datasheet supervisor."
  (if set (setf (slot-value 'supervisor) objid))
  (slot-value 'supervisor))

(defmeth datasheet-proto :size-loc (&optional (alist nil set))
  "Message args: (&optional logical) Sets or retrieves the list of width, height, x and y values, if any."
  (if set (setf (slot-value 'size-loc) alist))
  (slot-value 'size-loc))

(defmeth datasheet-proto :dash-vartype-menu (&optional (str nil set))
"Message args: (&optional logical)
 Sets or retrieves information about the object instance.."
  (if set (setf (slot-value 'dash-vartype-menu) str))
  (slot-value 'dash-vartype-menu))


(defmeth datasheet-proto :dash-menu-top-item (&optional (str nil set))
"Message args: (&optional logical)
 Sets or retrieves information about the object instance.."
  (if set (setf (slot-value 'dash-menu-top-item) str))
  (slot-value 'dash-menu-top-item))


(defmeth datasheet-proto :instance-info (&optional (str nil set))
"Message args: (&optional logical)
 Sets or retrieves information about the object instance.."
  (if set (setf (slot-value 'instance-info) str))
  (slot-value 'instance-info))


(defmeth datasheet-proto :button-bar-showing?  (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves information  about the button bar is visible."
  (if set (setf (slot-value 'button-bar-showing?) logical))
  (slot-value 'button-bar-showing?))


(defmeth datasheet-proto :menu-bar-showing?  (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves information about the menu bar is visible."
  (if set (setf (slot-value 'menu-bar-showing?) logical))
  (slot-value 'menu-bar-showing?))


(defmeth datasheet-proto :statobj-start-time (&optional (time nil set))
"Message args: (&optional logical)
 Sets or retrieves the start-time for this module. Used to calculate elapsed time."
  (if set (setf (slot-value 'statobj-start-time) time))
  (slot-value 'statobj-start-time))

(defmeth datasheet-proto :elapsed-time (&optional (time nil set))
"Method args: (&optional time)
 Sets or retrieves the elapsed time."
  (if set (setf (slot-value 'elapsed-time) time))
  (slot-value 'elapsed-time))

(defmeth datasheet-proto :determine-data-type ()
  (send (send self :data-object) :determine-data-type))

            
#|
(defmeth datasheet-proto :make-names (name)
  (send self :name name)
  (send self :proper-name nil)
  (send self :proper-name (send self :make-proper-name))
  (send self :full-name (send self :proper-name))
  (send self :object-id nil)
  (send self :object-id)
  (send self :proper-name))
|#

(defmeth datasheet-proto :make-names (name)
  (let ((names (make-names name ".dsh")))
    (send self :name (first names))
    (send self :full-name (second names))
    (send self :proper-name (third names))
    (send self :elipsis-name (fourth names))
    (send self :nickname (fifth names))
    (send self :extension (sixth names))
    (send self :object-id nil)
    (send self :object-id)
    (send self :proper-name)))

(defmeth datasheet-proto :object-id (&optional (objid nil set))
"Message args: (&optional logical)
 Sets or retrieves the object id string."
  (when (not (slot-value 'object-id)) 
        (slot-value 'object-id (send self :make-object-id)))
  (if set (setf (slot-value 'object-id) objid))
  (slot-value 'object-id))


(defmeth datasheet-proto :make-object-id (&optional (stream *standard-output*))
  (format nil "#<Object: ~a; StObjType: ~a;>~%"
          (send self :proper-name)
          (send self :make-vistatype)))


(defmeth datasheet-proto :make-proper-name ()
    (proper-name (first (parse-name (send self :name))) "dsh"))

;fwy!!!
(defmeth datasheet-proto :subject-id  (&optional (stream *standard-output*))
  (if (send self :data-object)
      (send (send self :data-object) :object-id stream)
      ("unknown subject")))

(defmeth datasheet-proto :make-vistatype ()
  (strcat "DataSheet"
          (if (send self :editable) "Editor" "Browser")
          (if (equal "matrix" (string-downcase (send self :data-type)))
              (format nil "[~ax~ax~a]" 
                      (send self :nvar) (send self :nvar) (send self :nmat))
              (format nil "[~ax~a]" (send self :nobs) (send self :nvar)))))

(defmeth datasheet-proto :vistatype () 
  (send self :make-vistatype))

(defmeth datasheet-proto :print (&optional (stream *standard-output*))
"Method args: (&optional (stream *standard-output*))
Default object printing method."
  (format stream "~a" (send self :proper-name)))

(defmeth datasheet-proto :info (&optional (stream *standard-output*) 
                                   &key (verbose nil) (subject nil))
   (format stream   "; ~a: ~a; ~a; ~,4d seconds~%> "
           (if (send self :editable) "Editor" "Browsr")
           (send self :proper-name)
           (send self :make-vistatype)
           (fuzz (send self :elapsed-time) 3)
           )
   (when (or verbose *history*)
         (unless (equal (string-downcase (send self :name)) "hidden")
                 (format stream   ";         RealName:  ~a~%" (send self :proper-name))
                 (format stream   ";         DataSheet: ~a~%" (send self :make-vistatype))
                 (format stream   ";         ProtoType: ~a~%" 
                         (string-capitalize (send self :slot-value 'proto-name)))
                 (format stream   ";         Address:   ~d~%" (address-of self))
                 (format stream   ";         Created:   ~a~%" 
                         (send self :slot-value 'instance-info))
                 (format stream   ";         Elapsed:   ~,4d seconds~%" 
                         (fuzz (send self :elapsed-time) 3))))
     )

;(defmeth datasheet-proto :statistical-object-type 
;   (&optional (string nil set))
;"Message args: (&optional string)
;Sets or retrieves the type of stat object (data or model)."
;  (if set (setf (slot-value 'statistical-object-type) string))
;  (slot-value 'statistical-object-type))

(defmeth datasheet-proto :statistical-object-type (&optional (logical nil set))
;written this way to prevent changing slot to invalid value
    (setf (slot-value 'statistical-object-type) "dash")
    (slot-value 'statistical-object-type))

(defmeth datasheet-proto :container (&optional (obj-id nil set))
"Message args: (&optional obj-id)
 Sets or retrieves the object-id of the container window for this datasheet."
  (if set (setf (slot-value 'container) obj-id))
  (slot-value 'container))

(defmeth datasheet-proto :data-object (&optional (obj-id nil set))
"Message args: (&optional obj-id)
 Sets or retrieves the object-id of the data object for this datasheet."
  (if set (setf (slot-value 'data-object) obj-id))
  (slot-value 'data-object))

(defmeth datasheet-proto :dash-popup-menu (&optional (obj-id nil set))
"Message args: (&optional obj-id)
 Sets or retrieves the object-id of the popup menu for this datasheet."
  (if set (setf (slot-value 'dash-popup-menu) obj-id))
  (slot-value 'dash-popup-menu))

(defmeth datasheet-proto :icon (&rest args)
  (apply #'send self :dash-icon args))

(defmeth datasheet-proto :dash-icon (&optional (obj-id nil set))
"Message args: (&optional obj-id)
 Sets or retrieves the object-id of the datasheet icon object for this datasheet, if there is one."
  (if set (setf (slot-value 'dash-icon) obj-id))
  (slot-value 'dash-icon))


(defmeth datasheet-proto :data-matrix-strings (&optional (matrix nil set))
"Message args: (&optional matrix)
 Sets or retrieves the data matrix with data as strings."
  (if set (setf (slot-value 'data-matrix-strings) matrix))
  (slot-value 'data-matrix-strings))

(defmeth datasheet-proto :variable-strings (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the list of variable strings."
  (if set (setf (slot-value 'variable-strings) list))
  (slot-value 'variable-strings))

(defmeth datasheet-proto :label-strings (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the list of label strings."
  (if set (setf (slot-value 'label-strings) list))
  (slot-value 'label-strings))

(defmeth datasheet-proto :type-strings (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the list of type strings."
  (if set (setf (slot-value 'type-strings) list))
  (slot-value 'type-strings))

(defmeth datasheet-proto :matrix-strings (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the list of matrix name strings."
  (if set (setf (slot-value 'matrix-strings) list))
  (slot-value 'matrix-strings))

(defmeth datasheet-proto :editable (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet is editable."
  (if set (setf (slot-value 'editable) logical))
  (slot-value 'editable))

(defmeth datasheet-proto :edited (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet has been edited."
  (if set (setf (slot-value 'edited) logical))
  (slot-value 'edited))

(defmeth datasheet-proto :showing (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet window is showing."
  (if set (setf (slot-value 'showing) logical))
  (slot-value 'showing))

(defmeth datasheet-proto :top-window (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet window is the top datasheet window."
  (if set (setf (slot-value 'top-window) logical))
  (slot-value 'top-window))

(defmeth datasheet-proto :nobs (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of observations in the datasheet."
  (if set (setf (slot-value 'nobs) number))
  (slot-value 'nobs))

(defmeth datasheet-proto :nvar (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of variables in the datasheet."
  (if set (setf (slot-value 'nvar) number))
  (slot-value 'nvar))

(defmeth datasheet-proto :newobs (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of observations in the datasheet."
  (if set (setf (slot-value 'newobs) number))
  (slot-value 'newobs))

(defmeth datasheet-proto :newvar (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of variables in the datasheet."
  (if set (setf (slot-value 'newvar) number))
  (slot-value 'newvar))

(defmeth datasheet-proto :newmat (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of variables in the datasheet."
  (if set (setf (slot-value 'newmat) number))
  (slot-value 'newmat))

(defmeth datasheet-proto :nmat (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of matrices in the datasheet."
  (if set (setf (slot-value 'nmat) number))
  (slot-value 'nmat))

(defmeth datasheet-proto :field-width (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the field width of the datasheet."
  (if set (setf (slot-value 'field-width) number))
  (slot-value 'field-width))

(defmeth datasheet-proto :field-height (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the field height of the datasheet."
  (if set (setf (slot-value 'field-height) number))
  (slot-value 'field-height))

(defmeth datasheet-proto :label-width (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the label width of the datasheet."
  (if set (setf (slot-value 'label-width) number))
  (slot-value 'label-width))

(defmeth datasheet-proto :corner-width (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the corner width of the datasheet."
  (if set (setf (slot-value 'corner-width) number))
  (slot-value 'corner-width))

(defmeth datasheet-proto :x+ (&optional (number nil set))
"Message args: (&optional number)
 x-offset for the datasheet."
  (if set (setf (slot-value 'x+) number))
  (slot-value 'x+))

(defmeth datasheet-proto :y+ (&optional (number nil set))
"Message args: (&optional number)
 y-offset for the datasheet."
  (if set (setf (slot-value 'y+) number))
  (slot-value 'y+))

(defmeth datasheet-proto :hot-cell (&optional (number-list nil set))
"Message args: (&optional number-list)
 Sets or retrieves a list of the row and column of the highlighted cell."
  (if set (setf (slot-value 'hot-cell) number-list))
  (slot-value 'hot-cell))

(defmeth datasheet-proto :hot-cell-ready (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the hot cell is ready for typing."
  (if set (setf (slot-value 'hot-cell-ready) logical))
  (slot-value 'hot-cell-ready))

(defmeth datasheet-proto :name (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the objects name string."
  (if set (setf (slot-value 'name) string))
  (slot-value 'name))

(defmeth datasheet-proto :elipsis-name (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the objects elipsis-name string."
  (if set (setf (slot-value 'elipsis-name) string))
  (slot-value 'elipsis-name))

(defmeth datasheet-proto :proper-name (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the objects proper-name string."
  (if set (setf (slot-value 'proper-name) string))
  (slot-value 'proper-name))

(defmeth datasheet-proto :full-name (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the objects full-name string."
  (if set (setf (slot-value 'full-name) string))
  (slot-value 'full-name))

(defmeth datasheet-proto :extension (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the objects name extension string."
  (if set (setf (slot-value 'extension) string))
  (slot-value 'extension))

(defmeth datasheet-proto :hot-cell-string (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the hot cell string."
  (if set (setf (slot-value 'hot-cell-string) string))
  (slot-value 'hot-cell-string))

(defmeth datasheet-proto :data-type (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the datatype string."
  (if set (setf (slot-value 'data-type) string))
  (slot-value 'data-type))

(defmeth datasheet-proto :datatype-string (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the datatype string as printed at top of datasheet."
  (if set (setf (slot-value 'datatype-string) string))
  (slot-value 'datatype-string))

(defmeth datasheet-proto :datasize-string (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the datasize string as printed at top of datasheet."
  (if set (setf (slot-value 'datasize-string) string))
  (slot-value 'datasize-string))

(defmeth datasheet-proto :menu-states (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the hot cell is ready for typing."
  (if set (setf (slot-value 'menu-states) logical))
  (slot-value 'menu-states))

(defmeth datasheet-proto :new-data (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the data are new."
  (if set (setf (slot-value 'new-data) logical))
  (slot-value 'new-data))

(defmeth datasheet-proto :initial (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet is the initial datasheet."
  (if set (setf (slot-value 'initial) logical))
  (slot-value 'initial))

(defmeth datasheet-proto :number-of-decimals (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of decimals displayed in the datasheet."
  (if set (setf (slot-value 'number-of-decimals) number))
  (slot-value 'number-of-decimals))

(defmeth datasheet-proto :number-of-columns (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of columns displayed in the datasheet."
  (if set (setf (slot-value 'number-of-columns) number))
  (slot-value 'number-of-columns))

(defmeth datasheet-proto :redraw-now (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether redraw should be done (t) or delayed (nil)."
  (if set (setf (slot-value 'redraw-now) logical))
  (slot-value 'redraw-now))

(defmeth datasheet-proto :help-menu-installed (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether redraw should be done (t) or delayed (nil)."
  (if set (setf (slot-value 'help-menu-installed) logical))
  (slot-value 'help-menu-installed))

(defmeth datasheet-proto :discarded (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the changes were discarded."
  (if set (setf (slot-value 'discarded) logical))
  (slot-value 'discarded))

(defmeth datasheet-proto :needs-revealing (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet was cleared and needs to be revealed."
  (if set (setf (slot-value 'needs-revealing) logical))
  (slot-value 'needs-revealing))

(defmeth datasheet-proto :shrink-wrap? (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether shrink-wrapping is on or off."
  (if set (setf (slot-value 'shrink-wrap?) logical))
  (slot-value 'shrink-wrap?))


(defmeth datasheet-proto :editor (&optional (obj-id nil set))
"Message args: (&optional obj-id)
 Sets or retrieves the object-id of the editor window for this datasheet."
  (if set (setf (slot-value 'editor) obj-id))
  (slot-value 'editor))
